home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / KEYBOARD.SWG / 0053_a VERY Complete KB Unit.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-02  |  16KB  |  573 lines
  1. Unit KeybFAQ;
  2. (* This is version 0.90 of KEYBFAQ, a Unit that answers two questions
  3.  * often asked in the Pascal message area's:
  4.  * - How do I change my cursor ?
  5.  * - How can I perform input of String With certain limitations
  6.  *   (such as 'maximum length', 'only numbers' etc.)
  7.  *
  8.  * I will distribute this Unit *ONCE* in message form (three messages)
  9.  * because it takes up 500 lines of code. It is untested code, cut from
  10.  * my Unit library, and distributed *as is* With no other documentation
  11.  * than these initial lines. You can use this code in your apps as you like,
  12.  * and you can redistribute it, provided you:
  13.  * - redistribute *source* code;
  14.  * - do not Charge anything For the source code;
  15.  * - give me credit For the original code if you change anything;
  16.  * - keep this 'documentation' With it.
  17.  * (Loosely translated: common decency is enough)
  18.  * Copyright will formally remain mine.
  19.  *
  20.  * Please do not respond about this code. I am going away For a few weeks
  21.  * and will distribute version 1.0 in ZIP form after that. That package
  22.  * will have *tested* code, docs and examples.
  23.  *
  24.  * Some notes about this code:
  25.  * - Use it always, or don't use it. I.e. if you start using GetKey
  26.  *   you should use that throughout your Program, and drop all ReadKeys.
  27.  * - The redefinition of Char into Key has two reasons:
  28.  *   - it allows better Type checking
  29.  *   - it allows future changes to the internal representation of the
  30.  *     Key Type (I plan to make it a Word Type to handle the overlap
  31.  *     in key definitions that is still present, and/or adapt Unicode
  32.  *     Character definitions)
  33.  * - The overlap in the Constant key definitions may look
  34.  *   problematic, but in the years I have been using this, it has not
  35.  *   posed any problems, generally because you only allow those keys
  36.  *   that have a meaning For your app.
  37.  *
  38.  * Happy Pascalling,
  39.  * Jan Doggen, 27/8/93 *)
  40.  
  41. Interface
  42.  
  43. Type
  44.   Key    = Char;
  45.   KeySet = Set of Key;
  46.   (* See later in this Interface section For defined sets *)
  47.  
  48. Var
  49.   BlankChar : Char;    (* Char used by GetStr to fill the bar; default ' ' *)
  50.  
  51. Procedure FlushKeyBuf;
  52. (* Clears the BIOS keyboard buffer *)
  53.  
  54. Function  InsertStatus : Boolean;
  55. Procedure SetInsertStatus(On : Boolean);
  56.  
  57. Procedure NiceBeep;
  58. (* Replaces the system beep With a more pleasant one. *)
  59.  
  60. Type
  61.   CursType = (NOCUR, LINECUR, BLOCKCUR);
  62.  
  63. Procedure SetCursor(CType: CursType);
  64. (* SetCursor sets a block or line cursor, or no cursor. *)
  65.  
  66. Function GetVidMode : Byte;
  67. (* Return BIOS video mode *)
  68.  
  69. Function MonoChrome(Vmode : Byte) : Boolean;
  70. (* Returns True if a monochrome video mode is specified *)
  71.  
  72. Function WinLeft   : Byte;
  73. Function WinRight  : Byte;
  74. Function WinTop    : Byte;
  75. Function WinBottom : Byte;
  76. (* Return Absolute co-ordinates of current Window *)
  77.  
  78. Function RepeatStr(Str : String; N : Integer) : String;
  79. (* Returns a String consisting of <N> repetitionsof <Str>. *)
  80.  
  81. Function GetKey : Key;
  82. (* Returns a Variable of Type Key; see the table below For the definitions.
  83.  * GetKey also accepts the <Alt-numeric keypad> ASCII codes. *)
  84.  
  85. Var
  86.   ClearOnFirstChar,
  87.   WalkOut,
  88.   StartInFront : Boolean;
  89.  (* These Booleans influence the way in which GetStr operates:
  90.   *
  91.   * With WalkOut = True: the left and right arrow keys also act as ExitKeys
  92.   * when they bring us 'outside' of the Word (we Exit the Procedure).
  93.   *
  94.   * With ClearOnFirstChar = True: if the first key Typed is a Character,
  95.   * the initial Str is cleared.
  96.   *
  97.   * With StartInFront = True: the cursor will be positioned at the first
  98.   * Character when we start the Procedure (instead of after the last)
  99.   *
  100.   * Default settings For these Booleans are False. *)
  101.  
  102. Procedure GetStr(Xpos, Ypos,
  103.                  MaxLen,
  104.                  Ink, Paper   : Byte;
  105.                  AllowedKeys,
  106.                  ExitKeys     : KeySet;
  107.                  BeepOnError  : Boolean;
  108.                  Var Str      : String;
  109.                  Var ExitKey  : Key);
  110. (* Reads a String of max. <MaxLen> Characters starting at relative position
  111.  * <XPos,YPos>. A bar of length <MaxLen> is placed there With colors
  112.  * <Ink> on <Paper>. An initial value For the String returned can be
  113.  * passed With <Str>.
  114.  *
  115.  * - BeepOnError indicates audio feedback on incorrect keypresses
  116.  * - AllowedKeys is a set of Keys that may be entered. if AllowedKeys = [],
  117.  *   all keys are allowed.
  118.  * - ExitKeys is a set of Keys that stop the Procedure; <Str> will then
  119.  *   contain the edited String and <ExitKey> will be key that made us Exit.
  120.  *   if ExitKeys is [], it will be replaced by [Enter,Escape].
  121.  *   The keys you specify in ExitKeys, do not have to be specified in
  122.  *   AllowedKeys. *)
  123.  
  124. Function WaitKey(LegalKeys : Keyset; Flush : Boolean) : Key;
  125. (* Waits For one of the keys in LegalKeys to be pressed, then returns this.
  126.  * if <Flush> = True, the keyboard buffer is flushed first. *)
  127.  
  128. Const
  129.   Null      = #0;    CtrlA = #1;   F1       = #187;  Home       = #199;
  130.   BSpace    = #8;    CtrlB = #2;   F2       = #188;  endKey     = #207;
  131.   Tab       = #9;    CtrlC = #3;   F3       = #189;  PgUp       = #201;
  132.   Lfeed     = #10;   CtrlD = #4;   F4       = #190;  PgDn       = #209;
  133.   Ffeed     = #12;   CtrlE = #5;   F5       = #191;  Left       = #203;
  134.   CReturn   = #13;   CtrlF = #6;   F6       = #192;  Right      = #205;
  135.   Escape    = #27;   CtrlG = #7;   F7       = #193;  Up         = #200;
  136.   ShiftTab  = #143;  CtrlH = #8;   F8       = #194;  Down       = #208;
  137.   CtrlPrtsc = #242;  CtrlI = #9;   F9       = #195;  Ins        = #210;
  138.   Enter     = #13;   CtrlJ = #10;  F10      = #196;  Del        = #211;
  139.   Esc       = #27;   CtrlK = #11;  ShiftF1  = #212;  CtrlLeft   = #243;
  140.   Space     = #32;   CtrlL = #12;  ShiftF2  = #213;  CtrlRight  = #244;
  141.                      CtrlM = #13;  ShiftF3  = #214;  CtrlendKey = #245;
  142.   { Note the     }   CtrlN = #14;  ShiftF4  = #215;  CtrlPgdn   = #246;
  143.   { overlap of   }   CtrlO = #15;  ShiftF5  = #216;  CtrlPgup   = #127;
  144.   { Ctrl-keys    }   CtrlP = #16;  ShiftF6  = #217;  CtrlHome   = #247;
  145.   { and others ! }   CtrlQ = #17;  ShiftF7  = #218;
  146.                      CtrlR = #18;  ShiftF8  = #219;
  147.                      CtrlS = #19;  ShiftF9  = #220;
  148.                      CtrlT = #20;  ShiftF10 = #221;
  149.                      CtrlU = #21;  CtrlF1   = #222;
  150.                      CtrlV = #22;  CtrlF2   = #223;
  151.                      CtrlW = #23;  CtrlF3   = #224;
  152.                      CtrlX = #24;  CtrlF4   = #225;
  153.                      CtrlY = #25;  CtrlF5   = #226;
  154.                      CtrlZ = #26;  CtrlF6   = #227;
  155.                      AltQ  = #144; CtrlF7   = #228;
  156.                      AltW  = #145; CtrlF8   = #229;
  157.                      AltE  = #146; CtrlF9   = #230;
  158.                      AltR  = #147; CtrlF10  = #231;
  159.                      AltT  = #148; AltF1    = #232;
  160.                      AltY  = #149; AltF2    = #233;
  161.                      AltU  = #150; AltF3    = #234;
  162.                      AltI  = #151; AltF4    = #235;
  163.                      AltO  = #152; AltF5    = #236;
  164.                      AltP  = #153; AltF6    = #237;
  165.                      AltA  = #158; AltF7    = #238;
  166.                      AltS  = #159; AltF8    = #239;
  167.                      AltD  = #160; AltF9    = #240;
  168.                      AltF  = #161; AltF10   = #241;
  169.                      AltG  = #162;
  170.                      AltH  = #163;
  171.                      AltJ  = #164;
  172.                      AltK  = #165;
  173.                      AltL  = #166; Alt1     = #248;
  174.                      AltZ  = #172; Alt2     = #249;
  175.                      AltX  = #173; Alt3     = #250;
  176.                      AltC  = #174; Alt4     = #251;
  177.                      AltV  = #175; Alt5     = #252;
  178.                      AltB  = #176; Alt6     = #253;
  179.                      AltN  = #177; Alt7     = #254;
  180.                      AltM  = #178; Alt8     = #255;  { No Alt9 or Alt0 ! }
  181.  
  182. { SETS }
  183.   LetterKeys   : KeySet = ['A'..'Z','a'..'z'];
  184.   SpecialKeys  : KeySet =
  185.     ['!','?','b','a','a','a','a','a','A','a','A','A','e','e','e',
  186.      'e','E','i','i','i','i','o','o','o','o','o','O','u','u','u',
  187.      'u','U','c','C','n','N'];
  188.   UpKeys       : KeySet = ['A'..'Z'];
  189.   LowKeys      : KeySet = ['a'..'z'];
  190.   VowelKeys    : KeySet = ['a','e','i','o','u','A','E','I','O','U'];
  191.   DigitKeys    : KeySet = ['0'..'9'];
  192.   OperatorKeys : KeySet = ['*','/','+','-'];
  193.   YNKeys       : KeySet = ['y','n','Y','N'];
  194.   JNKeys       : KeySet = ['j','n','J','N'];
  195.   BlankKeys    : KeySet = [#0..#32];
  196.   AllKeys      : KeySet = [#0..#255];
  197.   FKeys        : KeySet = [F1..F10];
  198.   ShiftFKeys   : KeySet = [ShiftF1..ShiftF10];
  199.   AltFKeys     : KeySet = [AltF1..AltF10];
  200.   CtrlFKeys    : KeySet = [CtrlF1..CtrlF10];
  201.   AllFKeys     : KeySet = [F1..F10,ShiftF1..AltF10];
  202.  
  203. Implementation
  204.  
  205. Uses Crt,Dos;
  206.  
  207. Procedure NiceBeep; (* Replaces the system beep With a more pleasant one. *)
  208. begin
  209.   Sound(300);
  210.   Delay(15);
  211.   NoSound;
  212. end;
  213.  
  214.  
  215. Procedure FlushKeyBuf;
  216. Var
  217.   Ch : Char;
  218. begin
  219.   While KeyPressed do
  220.     Ch := ReadKey;
  221. end;
  222.  
  223.  
  224. Function InsertStatus : Boolean;
  225. Var
  226.   Regs : Registers;
  227. begin
  228.   Regs.AH := 2;
  229.   Intr($16, Regs);
  230.   InsertStatus := ((Regs.AL and 128) = 128);
  231. end;
  232.  
  233.  
  234. Procedure SetInsertStatus(On: Boolean);
  235. begin
  236.   if ON then
  237.     Mem[$0040:$0017] := Mem[$0040:$0017] or 128
  238.   else
  239.     Mem[$0040:$0017] := Mem[$0040:$0017] and 127;
  240. end;
  241.  
  242.  
  243. Function GetVidMode: Byte;
  244. Var
  245.   Regs : Registers;
  246. begin
  247.   Regs.AH := $0F;
  248.   Intr($10, Regs);
  249.   GetVidMode := Regs.AL;
  250. end;
  251.  
  252.  
  253. Function MonoChrome(Vmode : Byte) : Boolean;
  254. begin
  255.   MonoChrome := (VMode in [0,2,5,6,7,15,17]);
  256. end;
  257.  
  258.  
  259. Function WinLeft : Byte;
  260. begin
  261.   WinLeft := Lo(WindMin) + 1;
  262. end;
  263.  
  264.  
  265. Function WinRight : Byte;
  266. begin
  267.   WinRight := Lo(WindMax) + 1;
  268. end;
  269.  
  270.  
  271. Function WinTop : Byte;
  272. begin
  273.   WinTop := Hi(WindMin) + 1;
  274. end;
  275.  
  276.  
  277. Function WinBottom : Byte;
  278. begin
  279.   WinBottom := Hi(WindMax) + 1;
  280. end;
  281.  
  282.  
  283. Function RepeatStr(Str : String; N : Integer) : String;
  284. Var
  285.   Result : String;
  286.   I, J,
  287.   NewLen,
  288.   Len    : Integer;
  289. begin
  290.   Len    := Length(Str);
  291.   NewLen := N * Length(Str);
  292.   Result[0] := Chr(NewLen);
  293.   J := 1;
  294.   For I := 1 to N DO
  295.   begin
  296.     Move(Str[1], Result[J], Len);
  297.     Inc(J, Len);
  298.   end;
  299.   RepeatStr := Result;
  300. end;
  301.  
  302.  
  303. Procedure SetCursor(CType : CursType);
  304. Var
  305.   VM   : Byte;
  306.   Regs : Registers;
  307. begin
  308.   VM := GetVidMode;
  309.   With Regs DO
  310.   Case CType OF
  311.     NOCUR :
  312.     begin
  313.       Regs.CX := $2000;      { Off-screen cursor position }
  314.       Regs.AH := 1;
  315.     end;
  316.  
  317.     LINECUR : begin
  318.       AX := $0100;
  319.       BX := $0000;
  320.       if MonoChrome(VM) then
  321.         CX := $0B0C
  322.       else
  323.         CX := $0607
  324.     end;
  325.  
  326.     BLOCKCUR :
  327.     begin
  328.       AX := $0100;
  329.       BX := $0000;
  330.       if MonoChrome(VM) then
  331.         CX := $010D
  332.       else
  333.         CX := $0107;
  334.     end;
  335.   end;
  336.   Intr($10, Regs);
  337. end;
  338.  
  339.  
  340. Function GetKey : Key;
  341. Var
  342.   Ch : Char;
  343. begin
  344.   Ch := ReadKey;
  345.   if Ch = #0 then
  346.   begin
  347.     Ch := ReadKey;
  348.     if Ch <= #127 then
  349.       GetKey := Chr(Ord(Ch) or $80)
  350.     else
  351.     if Ch = #132 then
  352.       GetKey := CtrlPgUp
  353.     else
  354.       GetKey := Null;
  355.   end
  356.   else
  357.     GetKey := Ch;
  358. end;
  359.  
  360. Procedure GetStr(XPos, YPos, MaxLen, Ink, Paper : Byte; AllowedKeys,
  361.                  ExitKeys : KeySet; BeepOnError : Boolean;
  362.                  Var Str : String; Var ExitKey : Key);
  363. Var
  364.   CursPos,
  365.   LeftPos,
  366.   TopPos,
  367.   RightPos,
  368.   BottomPos,
  369.   X, Y        : ShortInt;
  370.   InsFlag,
  371.   OAFlag,
  372.   FirstKey    : Boolean;
  373.   InKey       : Key;
  374.   OldTextAttr : Byte;
  375.   OldWindMin,
  376.   OldWindMax  : Word;
  377.  
  378.   Procedure CleanUp;
  379.   { Second level; called when we leave }
  380.   begin
  381.     WindMin  := OldWindMin;
  382.     WindMax  := OldWindMax;
  383.     TextAttr := OldTextAttr;
  384.     ExitKey  := InKey;
  385.   end;
  386.  
  387. begin
  388.   LeftPos   := WinLeft;
  389.   RightPos  := WinRight;
  390.   TopPos    := WinTop;
  391.   BottomPos := WinBottom;
  392.   X         := XPos + LeftPos - 1;
  393.   Y         := YPos + TopPos - 1;
  394.   InsFlag   := InsertStatus;
  395.   if ExitKeys = [] then
  396.     ExitKeys := [Enter, Escape];
  397.   if AllowedKeys = [] then
  398.     AllowedKeys := AllKeys;
  399.  (* Save old settings here; restore them in proc CleanUp when Exiting *)
  400.   OldWindMin := WindMin;
  401.   OldWindMax := WindMax;
  402.   WindMin := 0;             { Set Absolute Window co-ordinates and     }
  403.   WindMax := $FFFF;         { prevent scroll at lower right Character. }
  404.   OldTextAttr := TextAttr;
  405.   TextAttr := ((Paper SHL 4) or Ink) and $7F;
  406.   { Note: the 'AND $F' ensures that blink is off }
  407.   if StartInFront then
  408.     CursPos := 1
  409.   else
  410.   if Length(Str)+1 < MaxLen then
  411.     CursPos := Length(Str) + 1
  412.   else
  413.     CursPos := MaxLen;
  414.   FirstKey := True;
  415.   if InsFlag then
  416.     SetCursor(BLOCKCUR)
  417.   else
  418.     SetCursor(LINECUR);
  419.   Repeat
  420.     if CursPos < 1 then
  421.       if WalkOut then
  422.       begin
  423.         CleanUp;
  424.         Exit;
  425.       end
  426.       else
  427.       if BeepOnError then
  428.       begin
  429.         NiceBeep;
  430.         CursPos := 1;
  431.       end;
  432.  
  433.     if (CursPos > Length(Str) + 1) then
  434.       if WalkOut then
  435.       begin
  436.         CleanUp;
  437.         Exit;
  438.       end
  439.       else
  440.       if BeepOnError then
  441.       begin
  442.         NiceBeep;
  443.         CursPos := Length(Str) + 1;
  444.       end;
  445.  
  446.     if CursPos > MaxLen then
  447.       if WalkOut and (InKey = Right) then
  448.       begin
  449.         CleanUp;
  450.         Exit;
  451.       end
  452.       else
  453.       begin
  454.         if BeepOnError then
  455.           NiceBeep;
  456.         CursPos := MaxLen;
  457.       end;
  458.  
  459.     GotoXY(X, Y);
  460.     Write(Str + RepeatStr(BlankChar, MaxLen - Length(Str)));
  461.     GotoXY(X + CursPos - 1, Y);
  462.     InKey := GetKey;
  463.  
  464.     if InKey in ExitKeys then
  465.     begin
  466.       CleanUp;
  467.       Exit;
  468.     end;
  469.  
  470.     Case InKey OF
  471.       Left              : Dec(CursPos);
  472.       Right             : Inc(CursPos);
  473.       CtrlLeft, Home    : CursPos := 1;
  474.       CtrlRight, endKey : CursPos := Length(Str) + 1;
  475.       Tab               : Inc(CursPos,8);
  476.       ShiftTab          : Dec(CursPos,8);
  477.  
  478.       Ins :
  479.       begin
  480.         InsFlag := not InsFlag;
  481.         if InsFlag then
  482.           SetCursor(BLOCKCUR)
  483.         else
  484.           SetCursor(LINECUR);
  485.       end;
  486.  
  487.       Del :
  488.       if CursPos > Length(Str) then
  489.       begin
  490.         if BeepOnError then
  491.           NiceBeep;
  492.       end
  493.       else
  494.         Delete(Str, CursPos, 1);
  495.  
  496.       BSpace :
  497.       if CursPos = 1 then
  498.         if Length(Str) = 1 then
  499.           Str := ''
  500.         else
  501.         begin
  502.           if BeepOnError then
  503.             NiceBeep;
  504.         end
  505.         else
  506.         begin
  507.           Delete(Str, CursPos - 1, 1);
  508.           Dec(CursPos);
  509.         end;
  510.       else
  511.       begin
  512.         (* Note that 'AllowedKeys' that also have a
  513.         * meaning as a control key have already been
  514.         * processed, so they will not be handled here. *)
  515.         if InKey in AllowedKeys then
  516.         begin
  517.           if ClearOnFirstChar and FirstKey then
  518.           begin
  519.             Str     := '';
  520.             CursPos := 1;
  521.           end;
  522.           if (CursPos = MaxLen) then
  523.           begin
  524.             Str[CursPos] := InKey;
  525.             Str[0]       := Chr(MaxLen);
  526.           end
  527.           else
  528.           if InsFlag then
  529.           begin
  530.             Insert(InKey,Str,CursPos);
  531.             if Length(Str) > MaxLen then
  532.               Str[0] := Chr(MaxLen);
  533.           end
  534.           else
  535.           begin
  536.             Str[CursPos] := InKey;
  537.             if CursPos > Length(Str) then
  538.               Str[0] := Chr(CursPos);
  539.           end;
  540.  
  541.           Inc(CursPos);
  542.         end
  543.         else
  544.         if BeepOnError then
  545.           NiceBeep;
  546.       end;
  547.     end;
  548.  
  549.     FirstKey := False;
  550.   Until 0 = 1;
  551. end;
  552.  
  553.  
  554. Function WaitKey(LegalKeys : Keyset; Flush : Boolean) : Key;
  555. Var
  556.   K : Key;
  557. begin
  558.   if Flush then
  559.     FlushKeybuf;
  560.   Repeat
  561.     K := GetKey;
  562.   Until K in LegalKeys;
  563.   WaitKey := K;
  564. end;
  565.  
  566.  
  567. begin
  568.   BlankChar        := ' ';
  569.   WalkOut          := False;
  570.   ClearOnFirstChar := False;
  571.   StartInFront     := False;
  572. end.
  573.